;; core/lambdaK.scm - (c) rohan drape, 2000-2005

;; A keyword is a symbol that terminates with a colon.  Keywords can
;; be made self-evaluating.

(define (keyword? s)
  (and (symbol? s)
       (let ((s_ (symbol->string s)))
	 (eq? (string-ref s_ (- (string-length s_) 1)) #\:))))

;; Make a <function> that will rewrite an input <list> to conform to
;; the <list> `descriptor'.  Each element of `descriptor' must be a
;; duple {name default}.  The rewriter parses keywords for variable
;; names.  The result is a <list> of exactly the number of arguments
;; required by the specification `descriptor', default values are used
;; if any arguments are not supplied.  Raises an error if `descriptor'
;; is not legal.  The resulting procedure will raise an error if it's
;; input is malformed, in which case the <symbol> `title' is given as
;; part of the error.

(define (lambdaK-rewriter title descriptor)
  (if (not (every (lambda (e)
		    (and (list? e) 
			 (= (length e) 2)
			 (symbol? (car e))))
		  descriptor))
      (error "lambdaK-rewriter: illegal descriptor" title descriptor)
      (match 
       (let ((d (map (lambda (e) 
		       (if (list? e) e (list e #f)))
		     descriptor)))
	 (list (length d) 
	       (map (compose (lambda (n) 
			       (string->symbol (format "~a:" n)))
			     car) 
		    d) 
	       (map cadr d)))
       ((list arity names defaults)
	(lambda (input)
	  (let ((n (length input)))
	    ;; Fast path for the case where there are no keywords and
	    ;; all arguments are specified.
	    (if (not (find keyword? input))
		(cond ((= n arity)
		       input)
		      ((> n arity)
		       (error "Too many arguments:" title input))
		      (else
		       (append input (drop defaults n))))
		(let* ((pivot (list-index keyword? input))
		       (ordinary (take input pivot))
		       (alternate (drop input pivot)))
		  (append ordinary
			  (map (lambda (n d)
				 (let ((t (find-tail (lambda (e) 
						       (eq? e n)) 
						     alternate)))
				   (if t (cadr t) d)))
			       (drop names pivot)
			       (drop defaults pivot)))))))))))

;; A variant <function> constructor that supports default values,
;; positional arguments, and keyword arguments.

(define-syntax lambdaK/title
  (syntax-rules ()
    ((_ t () e ...)
     (lambda () e ...))
    ((_ t ((n d) ...) e ...)
     (let ((rewriter (lambdaK-rewriter t '((n d) ...))))
       (lambda args
	 (apply (lambda (n ...) e ...)
		(rewriter args)))))))

(define-syntax lambdaK
  (syntax-rules () 
    ((_ arguments body ...) (lambdaK/title 'unknown arguments body ...))))

(define-syntax defineK
  (syntax-rules ()
    ((_ (n a ...) e ...) (define n (lambdaK/title 'n (a ...) e ...)))))

;; A variant that redefines an exising value using set!

(define-syntax defineK* 
  (syntax-rules ()
    ((_ (n a ...) e ...) (set! n (lambdaK/title 'n (a ...) e ...)))))

